{- git-annex multicast receive callback
-
- - Copyright 2017 Joey Hess <id@joeyh.name>
+ - Copyright 2017-2025 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE CPP #-}
+
module Annex.Multicast where
import Common
import Annex.Path
import Utility.Env
-import Utility.Process
-import GHC.IO.Handle.FD
+#ifndef mingw32_HOST_OS
+import System.Posix.IO
+#else
+import System.Process (createPipeFd)
+#endif
multicastReceiveEnv :: String
multicastReceiveEnv = "GIT_ANNEX_MULTICAST_RECEIVE"
multicastCallbackEnv :: IO (OsPath, [(String, String)], Handle)
multicastCallbackEnv = do
gitannex <- programPath
- -- This will even work on Windows
+#ifndef mingw32_HOST_OS
+ (rfd, wfd) <- noCreateProcessWhile $ do
+ (rfd, wfd) <- createPipe
+ setFdOption rfd CloseOnExec True
+ return (rfd, wfd)
+#else
(rfd, wfd) <- createPipeFd
+#endif
rh <- fdToHandle rfd
environ <- addEntry multicastReceiveEnv (show wfd) <$> getEnvironment
return (gitannex, environ, rh)
docopynoncow iv = do
#ifndef mingw32_HOST_OS
- let open = do
+ let open = noCreateProcessWhile $ do
fd <- openFdWithMode f' ReadOnly Nothing
defaultFileFlags (CloseOnExecFlag True)
-- Need a duplicate fd for the post check.
import qualified Data.ByteString.Lazy as BSL
#ifndef mingw32_HOST_OS
import System.Posix.IO
+import Utility.Process
#endif
closeOnExec :: Bool
:: OsPath -> BS.ByteString -> IO ()
appendFile' fp contents = withFile fp AppendMode (`BS.hPut` contents)
-{- Unlike all other functions in this module, this only sets the
- - close-on-exec flag after opening the file. Thus, it is vulnerable to
- - races.
- -
- - Re-implementing openTempFile is difficult due to the current
+{- Re-implementing openTempFile is difficult due to the current
- structure of file-io. See this issue for discussion about improving
- that: https://github.com/haskell/file-io/issues/44
+ - So, instead this uses noCreateProcessWhile.
- -}
openTempFile :: OsPath -> OsString -> IO (OsPath, Handle)
-openTempFile tmp_dir template = do
- (p, h) <- I.openTempFile tmp_dir template
-#ifndef mingw32_HOST_OS
- fd <- handleToFd h
- setFdOption fd CloseOnExec True
- h' <- fdToHandle fd
- pure (p, h')
+openTempFile tmp_dir template =
+#ifdef mingw32_HOST_OS
+ I.openTempFile tmp_dir template
#else
- pure (p, h)
+ noCreateProcessWhile $ do
+ (p, h) <- I.openTempFile tmp_dir template
+ fd <- handleToFd h
+ setFdOption fd CloseOnExec True
+ h' <- fdToHandle fd
+ pure (p, h')
#endif
#endif
#ifndef mingw32_HOST_OS
let setup = liftIO $ do
-- pipe the passphrase into gpg on a fd
- (frompipe, topipe) <- System.Posix.IO.createPipe
- setFdOption topipe CloseOnExec True
+ (frompipe, topipe) <- noCreateProcessWhile $ do
+ (frompipe, topipe) <- System.Posix.IO.createPipe
+ setFdOption topipe CloseOnExec True
+ return (frompipe, topipe)
toh <- fdToHandle topipe
t <- async $ do
B.hPutStr toh (passphrase <> "\n")
{- System.Process enhancements, including additional ways of running
- - processes, and logging.
+ - processes, logging, and amelorations for cases where FDs are not able to
+ - be opened with close-on-exec.
-
- Copyright 2012-2025 Joey Hess <id@joeyh.name>
-
forceSuccessProcess',
checkSuccessProcess,
withNullHandle,
+ noCreateProcessWhile,
createProcess,
withCreateProcess,
waitForProcess,
import System.IO
import Control.Monad.IO.Class
import Control.Concurrent.Async
+import Control.Concurrent
import qualified Data.ByteString as S
+import System.IO.Unsafe (unsafePerformIO)
data StdHandle = StdinHandle | StdoutHandle | StderrHandle
deriving (Eq)
(Just from, Just to, _, pid) <- createProcess p
return (pid, to, from)
--- | Wrapper around 'System.Process.createProcess' that does debug logging.
+-- | Runs an action, preventing any new processes from being started
+-- until it is finished.
+--
+-- Unfortunately, Haskell has a pervasive problem with the close-on-exec
+-- flag not being set when opening files. It's also difficult to portably
+-- dup or pipe a FD with the close-on-exec flag set. So, this can be used
+-- to run an action that opens a FD, and then calls setFdOption to set the
+-- close-on-exec flag, without risking a race with a process being forked
+-- at the same time.
+--
+-- Note that only one of these actions can run at a time, and long-duration
+-- actions are not advisable.
+noCreateProcessWhile :: (MonadIO m, MonadMask m) => (m a) -> m a
+noCreateProcessWhile = bracket setup cleanup . const
+ where
+ setup = liftIO $ takeMVar createProcessSem
+ cleanup () = liftIO $ putMVar createProcessSem ()
+
+-- | A shared global MVar. Processes are not created while it is empty.
+{-# NOINLINE createProcessSem #-}
+createProcessSem :: MVar ()
+createProcessSem = unsafePerformIO $ newMVar ()
+
+-- | Wrapper around 'System.Process.createProcess'.
+-- This adds debug logging, and avoids starting a process when in a
+-- noCreateProcessWhile block.
createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-createProcess p = do
+createProcess p = noCreateProcessWhile $ do
r@(_, _, _, h) <- Utility.Process.Shim.createProcess p
debugProcess p h
return r
#ifndef mingw32_HOST_OS
{- This implementation interleves stdout and stderr in exactly the order
- the process writes them. -}
- let setup = do
+ let setup = noCreateProcessWhile $ do
(readf, writef) <- System.Posix.IO.createPipe
System.Posix.IO.setFdOption readf System.Posix.IO.CloseOnExec True
System.Posix.IO.setFdOption writef System.Posix.IO.CloseOnExec True
#ifndef mingw32_HOST_OS
let setup = liftIO $ do
-- pipe the passphrase in on a fd
- (frompipe, topipe) <- System.Posix.IO.createPipe
- setFdOption topipe CloseOnExec True
+ (frompipe, topipe) <- noCreateProcessWhile $ do
+ (frompipe, topipe) <- System.Posix.IO.createPipe
+ setFdOption topipe CloseOnExec True
+ return (frompipe, topipe)
toh <- fdToHandle topipe
t <- async $ do
B.hPutStr toh (password <> "\n")
[[!meta author=yoh]]
[[!tag projects/repronim]]
+
+> [[fixed|done]] --[[Joey]]
However, since security is involved, it does need to be fixed comprehensively
in git-annex, including the remaining races.
-
-And, I have decided that this fix can't be tied to the OsPath flag being
-set. It needs to be fixed when git-annex is built without that flag, or the
-flag needs to go away.
"""]]
--- /dev/null
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 14"""
+ date="2025-09-10T18:27:50Z"
+ content="""
+Implemented the global MVar fix for remaining races.
+"""]]
projects / git-annex.git / commitdiff